home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / library.tcl < prev    next >
Encoding:
Text File  |  1999-04-20  |  27.1 KB  |  913 lines  |  [TEXT/ALFA]
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Some additions copyright (c) 1997-1998 Vince Darley.
  11.  
  12. set errorCode ""
  13. set errorInfo ""
  14.  
  15. if {[info commands tclLog] == ""} {
  16.     proc tclLog {args} {
  17.     message [string trim [join $args ""] "\r"]
  18.     }
  19. }
  20. if {[info tclversion] >= 8.0} {
  21.     namespace eval index {}
  22.     namespace eval procs {}
  23.     # used to force some child namespaces into existence
  24.     ;proc namesp {var} {
  25.     if {[catch "uplevel global $var"]} {
  26.         set ns ""
  27.         while {[regexp "^(::)?($ns\[a-zA-Z_\]+::)" $var ns]} {
  28.         uplevel "namespace eval $ns {}"
  29.         }
  30.     }
  31.     }
  32. } else {
  33.     ;proc namesp {var} {}
  34.     rename load evaluate
  35. }
  36.  
  37. # 7.1 doesn't rename unbind in the actual application
  38. if {[info commands unBind] == ""} { rename unbind unBind }
  39.  
  40. # define compatibility procs for menu, bind, unbind
  41. if {[info commands bind] == ""} {
  42.     proc bind {args} { uplevel 1 Bind $args }
  43.     proc unbind {args} { uplevel 1 unBind $args }
  44.     proc menu {args} { 
  45.     regsub -all "\{menu " $args "\{Menu " args
  46.     uplevel 1 Menu $args 
  47.     }
  48. }
  49. namespace eval file {}
  50. # determine platform specific directory symbol
  51. regexp {Z(.)Z} [file join Z Z] "" file::separator
  52.  
  53. ## 
  54.  # -------------------------------------------------------------------------
  55.  # 
  56.  # "unknown" --
  57.  # 
  58.  #  Almost the same as standard Tcl 8 unknown.  Since we're on a Mac,
  59.  #  I removed the auto_execok flag, and for some reason had to change
  60.  #  'history change $newcmd 0' to 'history change $newcmd'
  61.  # -------------------------------------------------------------------------
  62.  ##
  63. # unknown --
  64. # This procedure is called when a Tcl command is invoked that doesn't
  65. # exist in the interpreter.  It takes the following steps to make the
  66. # command available:
  67. #
  68. #    1. See if the autoload facility can locate the command in a
  69. #       Tcl script file.  If so, load it and execute it.
  70. #    2. If the command was invoked interactively at top-level:
  71. #        (a) see if the command exists as an executable UNIX program.
  72. #        If so, "exec" the command.
  73. #        (b) see if the command requests csh-like history substitution
  74. #        in one of the common forms !!, !<number>, or ^old^new.  If
  75. #        so, emulate csh's history substitution.
  76. #        (c) see if the command is a unique abbreviation for another
  77. #        command.  If so, invoke the command.
  78. #
  79. # Arguments:
  80. # args -    A list whose elements are the words of the original
  81. #        command, including the command name.
  82. proc unknown args {
  83.     global auto_noload env unknown_pending tcl_interactive
  84.     global errorCode errorInfo
  85.     
  86.     # Save the values of errorCode and errorInfo variables, since they
  87.     # may get modified if caught errors occur below.  The variables will
  88.     # be restored just before re-executing the missing command.
  89.     
  90.     set savedErrorCode $errorCode
  91.     set savedErrorInfo $errorInfo
  92.     set name [lindex $args 0]
  93.     if {![info exists auto_noload]} {
  94.     #
  95.     # Make sure we're not trying to load the same proc twice.
  96.     #
  97.     if {[info exists unknown_pending($name)]} {
  98.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  99.     }
  100.     set unknown_pending($name) pending;
  101.     set ret [catch {auto_load $name} msg]
  102.     unset unknown_pending($name);
  103.     if {$ret != 0} {
  104.         return -code $ret -errorcode $errorCode \
  105.           "error while autoloading \"$name\": $msg"
  106.     }
  107.     if {![array size unknown_pending]} {
  108.         unset unknown_pending
  109.     }
  110.     if {$msg} {
  111.         set errorCode $savedErrorCode
  112.         set errorInfo $savedErrorInfo
  113.         set code [catch {uplevel 1 $args} msg]
  114.         if {$code ==  1} {
  115.         #
  116.         # Strip the last five lines off the error stack (they're
  117.         # from the "uplevel" command).
  118.         #
  119.         
  120.         set new [split $errorInfo \n]
  121.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  122.         return -code error -errorcode $errorCode \
  123.           -errorinfo $new $msg
  124.         } else {
  125.         return -code $code $msg
  126.         }
  127.     }
  128.     }
  129.     if {([info level] == 1) && ([info script] == "") \
  130.       && [info exists tcl_interactive] && $tcl_interactive} {
  131.     set errorCode $savedErrorCode
  132.     set errorInfo $savedErrorInfo
  133.     if {$name == "!!"} {
  134.         set newcmd [history event]
  135.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  136.         set newcmd [history event $event]
  137.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  138.         set newcmd [history event -1]
  139.         catch {regsub -all -- $old $newcmd $new newcmd}
  140.     }
  141.     if {[info exists newcmd]} {
  142.         tclLog "\r" $newcmd
  143.         history change $newcmd
  144.         return [uplevel $newcmd]
  145.     }
  146.     
  147.     set ret [catch {set cmds [info commands $name*]} msg]
  148.     if {[string compare $name "::"] == 0} {
  149.         set name ""
  150.     }
  151.     if {$ret != 0} {
  152.         return -code $ret -errorcode $errorCode \
  153.           "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  154.     }
  155.     if {[llength $cmds] == 1} {
  156.         return [uplevel [lreplace $args 0 0 $cmds]]
  157.     }
  158.     if {[llength $cmds] != 0} {
  159.         if {$name == ""} {
  160.         return -code error "empty command name \"\""
  161.         } else {
  162.         return -code error \
  163.           "ambiguous command name \"$name\": [lsort $cmds]"
  164.         }
  165.     }
  166.     }
  167.     return -code error "invalid command name \"$name\""
  168. }
  169.  
  170. ## 
  171.  # -------------------------------------------------------------------------
  172.  # 
  173.  # "auto_load" --
  174.  # 
  175.  #  I use this separate proc to be closer to the standard Tcl 8 system
  176.  #  of unknown-loading.
  177.  # -------------------------------------------------------------------------
  178.  ##
  179. proc auto_load cmd {
  180.     set f [procs::find $cmd]
  181.     if {$f != ""} {
  182.     uplevel \#0 source [list $f]
  183.     return [expr {[llength [info commands $cmd]] != 0}]
  184.     }
  185.     if {[regsub {^::} $cmd "" cmd]} {
  186.     set f [procs::find $cmd]
  187.     if {$f != ""} {
  188.         uplevel \#0 source [list $f]
  189.         return [expr {[llength [info commands $cmd]] != 0}]
  190.     }
  191.     }
  192.     # to cope with some Tcl 8 package stuff
  193.     global auto_index
  194.     if {[info exists auto_index($cmd)]} {
  195.     uplevel #0 $auto_index($cmd)
  196.     return [expr {[llength [info commands $cmd]] != 0}]
  197.     }
  198.     return 0
  199. }
  200.  
  201. # auto_mkindex:
  202. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  203. # the name of the directory in which the tclIndex file is to be placed,
  204. # and a glob pattern to use in that directory to locate all of the relevant
  205. # files.
  206. proc auto_mkindex {dir {files *.tcl}} {    
  207.     set oldDir [pwd]
  208.     cd $dir
  209.     append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
  210.     append line "set \"[file tail [string trim [pwd] :]]_index\" \{\n"
  211.     
  212.     set cid [scancontext create]
  213.     scanmatch $cid {^[     ]*proc[     ]} {
  214.     if {[regexp {^[     ]*proc[     ]+(("[^"]+")|(\{[^\}]+\})|([^     ]*))} $matchInfo(line) match procName]} {
  215.         append line "$procName "
  216.     }
  217.     }
  218.     
  219.     foreach file [glob $files] {
  220.     watchCursor
  221.     set f ""
  222.     append line "\{[file tail $file]\14 "
  223.     message [file tail $file]
  224.     set fid [open $file]
  225.     scanfile $cid $fid
  226.     close $fid
  227.     append line "\}\n"
  228.     }
  229.     
  230.     scancontext delete $cid
  231.     
  232.     append line "\}\n"
  233.     catch {
  234.     set f [open tclIndexx w]
  235.     puts -nonewline $f $line
  236.     close $f
  237.     }
  238.     cd $oldDir
  239.     
  240.     foreach i [info vars {*_index}] {
  241.     global $i
  242.     unset $i
  243.     }
  244. }
  245.  
  246. proc procs::find {cmd} {
  247.     global auto_path
  248.     
  249.     regsub -all {[][\$?^|*+()\{\}]} $cmd {\\&} cmd
  250.     foreach path $auto_path {
  251.     if {![file exists $path]} continue
  252.     if {![catch {file readlink $path} _path]} {
  253.         set path $_path
  254.     }
  255.     set index "[file tail $path]_index"
  256.     global $index
  257.     if {![info exists $index]} {
  258.         if {![file exists [file join $path tclIndexx]]} continue
  259.         uplevel \#0 source [list [file join $path tclIndexx]]
  260.     }
  261.     if {[regexp "\n\{(\[^\14\]+)\14\[^\n\]* \[\"\{\]?(::)?${cmd}\[\"\}\]? " [set $index] dummy file]} {
  262.         return [file join $path $file]
  263.     }
  264.     }
  265.     return ""
  266. }
  267. # this proc adds 'dummy' so 'file dirname' works the same
  268. # way for tcl7.4 and tcl8.0.
  269. proc alpha::makeAutoPath {{check_dups 1} {skipPrefs 0}} {
  270.     global HOME auto_path file::separator
  271.     if {$check_dups} {
  272.     set lcmd lunion
  273.     } else {
  274.     set lcmd lappend
  275.     }
  276.     set root [file join $HOME Tcl]
  277.     if {![catch {file readlink $root} _root]} {
  278.     set root $_root
  279.     }
  280.     
  281.     foreach dir {SystemCode Modes Menus} {
  282.     $lcmd auto_path [file join $root $dir]
  283.     foreach d [glob -nocomplain "[file join $root $dir *]${file::separator}"] {
  284.         $lcmd auto_path [file dirname "${d}dummy"]
  285.     }
  286.     }
  287.     if {!$skipPrefs} {
  288.     $lcmd auto_path [file join $root Packages]
  289.     $lcmd auto_path [file join $root UserModifications]
  290.     foreach d [glob -nocomplain "[file join $root Packages *]${file::separator}"] {
  291.         $lcmd auto_path [file dirname "${d}dummy"]
  292.     }
  293.     }
  294.     
  295. }
  296.  
  297. # Clean up temporary files:
  298. proc removeTemporaryFiles {} {
  299.     global PREFS
  300.     if {[file exists [file join $PREFS tmp]]} {
  301.     foreach f [glob -nocomplain [file join $PREFS tmp *]] {
  302.         message "removing [file tail $f]…"
  303.         file delete $f
  304.     }
  305.     }
  306.     message "all temporary files removed"
  307. }
  308. ## 
  309.  # -------------------------------------------------------------------------
  310.  # 
  311.  # "auto_reset" --
  312.  # 
  313.  #  After rebuilding indices, Tcl retains its old index information unless
  314.  #  we tell it not to.
  315.  # -------------------------------------------------------------------------
  316.  ##
  317. proc auto_reset {} {
  318.     global auto_path
  319.     foreach path $auto_path {
  320.     if {![file exists $path]} continue
  321.     set index "[file tail $path]_index"
  322.     global $index
  323.     catch {unset $index}
  324.     }
  325. }
  326.  
  327. #================================================================================
  328. # Wonderful procs from Vince Darley (darley@fas.harvard.edu).
  329. #===============================================================================
  330.  
  331. if {[info tclversion] < 8.0} {
  332. proc traceTclProc {{func ""}} {
  333.     global tclMenu
  334.     if {[llength [traceFunc status]]>2} {
  335.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  336.     catch {enableMenuItem $tclMenu dumpTraces off}
  337.     if {[string length [set data [traceDump]]]} {
  338.         if {[dialog::yesno "Dump traces?"]} {
  339.         dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  340.         }
  341.     }
  342.     traceFunc off
  343.     message "Tracing off."
  344.     return
  345.     }
  346.     if {$func == ""} {
  347.     set func [procs::pick 1]
  348.     }
  349.     if {![string length $func]} return
  350.     traceFunc on $func ""
  351.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  352.     catch {enableMenuItem $tclMenu dumpTraces on}
  353.     message "Tracing '$func'…"
  354. }
  355.  
  356.  
  357. proc dumpTraces {{name ""} {data ""}} {
  358.     if {![string length $name]} {
  359.     set name [string trimright [lindex [traceFunc status] 3] {,}]
  360.     }
  361.     if {![string length $data]} {
  362.     set data [traceDump]
  363.     }
  364.     
  365.     if {![string length $data]} {
  366.     message "Trace buffer empty"
  367.     } else {
  368.     new -n "* Trace '$name' *" -m Tcl -info $data
  369.     }
  370. }
  371.  
  372. proc procs::traceProc {func} {
  373.     global tclMenu
  374.     # if we're tracing already then clear it
  375.     if {[llength [traceFunc status]]>2} { traceTclProc }
  376.     traceFunc on $func ""
  377.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  378.     catch {enableMenuItem $tclMenu dumpTraces on}
  379.     message "Tracing '$func'…"
  380. }
  381.  
  382. proc procs::pick {{try_sel 0}} {
  383.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  384.     if {[info procs $sel] == "$sel"} {
  385.         return $sel
  386.     } else {
  387.         return [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  388.     }
  389.     } else {
  390.     return [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  391.     }
  392. }
  393.  
  394. } else {
  395. proc procs::traceProc {func} {
  396.     uplevel traceTclProc $func
  397. }
  398.  
  399. ## 
  400.  # -------------------------------------------------------------------------
  401.  # 
  402.  # "procs::pick" --
  403.  # 
  404.  #  Bug to be fixed:
  405.  #  only procs in top level namespace are returned by [info procs]
  406.  #  Should probably implement a hierarchial choice process.
  407.  # -------------------------------------------------------------------------
  408.  ##
  409. proc procs::pick {{try_sel 0}} {
  410.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  411.     if {[llength [uplevel \#0 [list info commands $sel]]] && ![catch {info args $sel}]} {
  412.         return $sel
  413.     } else {
  414.         return [listpick -L $sel -p {Func Name:} [lsort -ignore [uplevel \#0 info procs]]]
  415.     }
  416.     } else {
  417.     return [listpick -p {Func Name:} [lsort -ignore [uplevel \#0 info procs]]]
  418.     }
  419. }
  420.  
  421. ## 
  422.  # -------------------------------------------------------------------------
  423.  # 
  424.  # "traceTclProc" --
  425.  # 
  426.  #  Trace and dump still need a little work under Alpha 8.0.  Notice that
  427.  #  traces are stored in a file, not in memory as in previous versions
  428.  #  of Alpha.
  429.  # -------------------------------------------------------------------------
  430.  ##
  431. proc traceTclProc {{func ""}} {
  432.     global tclMenu alpha::tracingProc alpha::tracingChannel PREFS
  433.     if {[cmdtrace depth] > 0} {
  434.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  435.     catch {enableMenuItem $tclMenu dumpTraces off}
  436.     catch {
  437.         cmdtrace off
  438.         close $alpha::tracingChannel
  439.         set alpha::tracingChannel ""
  440.     }
  441.     if {[file exists [file join $PREFS tmp traceDump]]} {
  442.         dumpTraces "" "" 1
  443.         file delete [file join $PREFS tmp traceDump]
  444.     }
  445.     message "Tracing off."
  446.     if {$func == ""} {return}
  447.     }
  448.     if {$func == ""} {
  449.     set func [procs::pick 1]
  450.     }
  451.     if {![string length $func]} return
  452.     if {![file exists [file join $PREFS tmp]]} {
  453.     file mkdir [file join $PREFS tmp]
  454.     }
  455.     set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  456.     cmdtrace on $alpha::tracingChannel inside $func
  457.     set alpha::tracingProc $func
  458.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  459.     catch {enableMenuItem $tclMenu dumpTraces on}
  460.     message "Tracing '$func'…"
  461. }
  462.  
  463.  
  464. proc dumpTraces {{name ""} {data ""} {ask 0}} {
  465.     global alpha::tracingProc alpha::tracingChannel PREFS
  466.     if {![string length $name]} {
  467.     set name $alpha::tracingProc
  468.     }
  469.     if {![string length $data]} {
  470.     set data [file::readAll [file join $PREFS tmp traceDump]]
  471.     if {$alpha::tracingChannel != ""} {
  472.         close $alpha::tracingChannel
  473.         file delete [file join $PREFS tmp traceDump]
  474.         set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  475.         cmdtrace configure $alpha::tracingChannel
  476.     }
  477.     }
  478.     
  479.     if {![string length $data]} {
  480.     message "Trace buffer empty"
  481.     } else {
  482.     if {$ask} {
  483.         if {![dialog::yesno "Dump traces?"]} {return}
  484.     }
  485.     new -n "* Trace '$name' *" -m Tcl -text $data -shell 1 -read-only 1
  486.     }
  487. }
  488.  
  489. }
  490.  
  491.  
  492. proc rebuildTclIndices {} {
  493.     global auto_path tcl_platform
  494.     set d [pwd]
  495.     foreach dir $auto_path {
  496.     # in case auto_path contains relative directories (bad idea)
  497.     cd
  498.     # if directory exists
  499.     if {![catch {cd $dir}]} {
  500.         # if there are any files
  501.         if {![catch { glob *.*tcl }]} {
  502.         message "Building [file tail $dir] index…"                
  503.         # use 'catch' also in case directory is write-protected
  504.         if {$tcl_platform(platform) == "macintosh"} {
  505.             catch { auto_mkindex : *.*tcl }
  506.         } else {
  507.             catch { auto_mkindex . *.*tcl }
  508.         }
  509.         }
  510.     }
  511.     }
  512.     message ""
  513.     cd $d
  514.     # make alpha forget its old information so the new stuff is loaded
  515.     # when required.
  516.     catch {auto_reset}
  517. }
  518.  
  519. set alpha::rebuilding 0
  520.  
  521. proc alpha::rebuildPackageIndices {} {
  522.     alpha::makeIndices
  523.     message "Indices and package menu rebuilt."
  524. }
  525.  
  526. proc alpha::makeIndices {} {
  527.     # add all new directories to the auto_path
  528.     alpha::makeAutoPath
  529.     # ensure count is correctly set - otherwise we'd probably have to
  530.     # rebuild next time we started up.
  531.     alpha::rectifyPackageCount
  532.     set types {index::feature index::mode index::uninstall  index::maintainer index::help index::disable}
  533.     global pkg_file HOME alpha::rebuilding alpha::version file::separator \
  534.       index::oldmode alpha::tclversion
  535.     eval global $types
  536.     # store old mode information so we can check what changed
  537.     catch {cache::read index::mode}
  538.     catch {array set index::oldmode [array get index::mode]}
  539.     
  540.     catch {eval cache::delete $types}
  541.     foreach type $types {
  542.     catch {unset $type}
  543.     }
  544.     foreach dir [list SystemCode Modes Menus Packages] {
  545.     lappend dirs "[file join ${HOME} Tcl ${dir}]${file::separator}"
  546.     eval lappend dirs [glob -nocomplain "[file join ${HOME} Tcl ${dir} *]${file::separator}"]
  547.     }
  548.     if {[file exists [file join ${HOME} AlphaCore]]} {
  549.     lappend dirs "[file join ${HOME} AlphaCore]${file::separator}"
  550.     }
  551.     set alpha::rebuilding 1
  552.     # provide the 'Alpha' and 'AlphaTcl' packages
  553.     ;alpha::extension Alpha ${alpha::version} {} help {file "Alpha Manual"}
  554.     ;alpha::extension AlphaTcl ${alpha::tclversion} {} help {file "Extending Alpha"}
  555.     # declare 2 different scan contexts:
  556.     set cid_scan [scancontext create]
  557.     scanmatch $cid_scan  "^\[ \t\]*alpha::(menu|mode|flag|extension|feature|package\[ \t\]+(uninstall|disable|maintainer|help))\[ \t\\\\\]" {
  558.     incr rebuild_cmd_count 1
  559.     }
  560.     scanmatch $cid_scan "^\[ \t\]*newPref\[ \t\]" {
  561.     if {[incr numprefs] == 1} {
  562.         set newpref_start $matchInfo(offset)
  563.     }
  564.     }
  565.     set cid_help [scancontext create]
  566.     scanmatch $cid_help "^\[ \t\]*#" {
  567.     if {[expr {$linenum +1}] != $matchInfo(linenum)} { set hhelp "" }
  568.     append hhelp [string trimleft $matchInfo(line) " \t#"] " "
  569.     set linenum $matchInfo(linenum)
  570.     }
  571.     scanmatch $cid_help "^\[ \t\]*newPref\[ \t\]" {
  572.     if {[expr {$linenum +1}] == $matchInfo(linenum)} {
  573.         if {$hhelp != ""} {
  574.         set pkg [lindex $matchInfo(line) 4]
  575.         # allow comment to over-ride the mode/package
  576.         regexp "^\\((\\w+)\\)\[ \t\]*(.*)\$" $hhelp "" pkg hhelp
  577.         if {$pkg == "" || $pkg == "global"} {
  578.             set prefshelp([lindex $matchInfo(line) 2]) $hhelp
  579.         } else {
  580.             set prefshelp($pkg,[lindex $matchInfo(line) 2]) $hhelp
  581.         }
  582.         }
  583.     }
  584.     set hhelp ""
  585.     if {[incr numprefs -1] == 0} {
  586.         error "done"
  587.     }
  588.     }
  589.     
  590.     global rebuild_cmd_count
  591.     foreach d $dirs {
  592.     foreach f [glob -nocomplain "${d}*.tcl"] {
  593.         if {![catch {open $f} fid]} {
  594.         message "scanning [file tail $f]…"
  595.         set numprefs 0
  596.         set rebuild_cmd_count 0
  597.         # check for 'newPref' or 'alpha::package' statements
  598.         scanfile $cid_scan $fid
  599.         if {$numprefs > 0} {
  600.             message "scanning [file tail $f]…($numprefs prefs)"
  601.             incr newpref_start -520
  602.             seek $fid [expr {$newpref_start > 0 ? $newpref_start : 0}]
  603.             set linenum -2
  604.             set hhelp ""
  605.             catch [list scanfile $cid_help $fid]
  606.         }
  607.         close $fid
  608.         if {$rebuild_cmd_count > 0} {
  609.             message "scanning [file tail $f] for packages"
  610.             set pkg_file $f
  611.             if {[catch {uplevel \#0 [list source $f]} res] != 11} {
  612.             if {[askyesno "Had a problem extracting package information from [file tail $f].  View error?"] == "yes"} {
  613.                 alertnote [string range $res 0 240]
  614.             }
  615.             }
  616.         }
  617.         }
  618.     }
  619.     }
  620.     catch {unset rebuild_cmd_count}
  621.     set alpha::rebuilding 0
  622.     
  623.     scancontext delete $cid_scan
  624.     scancontext delete $cid_help
  625.     cache::create index::prefshelp variable prefshelp
  626.     
  627.     foreach type $types {
  628.     cache::add $type "variable" $type
  629.     if {$type != "index::feature"} { catch {unset $type} }
  630.     }
  631.     catch {unset index::oldmode}
  632.     catch {unset pkg_file}
  633.     #foreach n [array names index::feature] {}
  634.     global alpha::requirements
  635.     if {[info exists alpha::requirements]} {
  636.     foreach itm ${alpha::requirements} {
  637.         set m [lindex $itm 0]
  638.         set req [lindex $itm 1]
  639.         if {[catch {package::versionCheck [lindex $req 0] [lindex $req 2]} err]} {
  640.         alertnote "$m mode requirements failure: $err  You should upgrade that package."
  641.         }
  642.     }
  643.     }
  644.     
  645.     message "Package index rebuilt."
  646. }
  647.  
  648. # 'exit' kills Alpha without allowing it to save etc.
  649. # 'quit' is therefore more mac-like
  650. rename exit ""
  651. proc exit {} {quit}
  652.  
  653. proc alpha::reportError {string} {
  654.     global reportErrors
  655.     if {$reportErrors} {
  656.     alertnote [string range $string 0 200]
  657.     } else {
  658.     global alpha::errorLog
  659.     append alpha::errorLog $string
  660.     }
  661. }
  662.  
  663. proc userMessage {{alerts 1} {message ""}} {
  664.     if {$alerts} {
  665.     alertnote $message
  666.     } else {
  667.     message $message
  668.     }
  669. }
  670.  
  671. namespace eval flag {}
  672.  
  673. # Always use this proc, don't mess with 'flag::types' directly.
  674. proc flag::addType {type} {
  675.     global flag::types
  676.     if {[lsearch -exact ${flag::types} $type] == -1} {
  677.     lappend flag::types $type
  678.     }
  679. }
  680.  
  681. # Declare basic preference types
  682. namespace eval flag {}
  683. set flag::types [list "flag" "variable" "binding" "menubinding" \
  684.   "file" "io-file" "funnyChars"]
  685. # Note: other types are triggered by vars ending in 'Colour', 'Color',
  686. # 'Folder', 'Path', 'Mode', 'Sig', or 'SearchPath'
  687.  
  688. ## 
  689.  # -------------------------------------------------------------------------
  690.  # 
  691.  # "newPref" --
  692.  # 
  693.  #  Define a new preference variable/flag.  You can call this procedure
  694.  #  either with multiple arguments or with a single list of all the
  695.  #  arguments.  So 'newPref flag Hey ...' or 'newPref {flag Hey ...}'
  696.  #  are both fine.
  697.  #  
  698.  #  'type' is one of:
  699.  #    'flag' (on/off only), 'variable' (anything), 'binding' (key-combo)
  700.  #    'menubinding' (key-combo which works in a menu), 'file' (input only),
  701.  #    'io-file' (either input or output).  Variables whose name ends in
  702.  #    Sig, Folder, Path, Mode, Colour, Color or SearchPath (case matters here) 
  703.  #    are treated differently, but are still considered of type 'variable'.
  704.  #    For convenience this proc will map types sig, folder, color, ...
  705.  #    into 'variable' for you, _if_ the variable ends with the correct
  706.  #    string.
  707.  #    
  708.  #  'name' is the var name, 
  709.  #  
  710.  #  'val' is its default value (which will be ignored if the variable
  711.  #  already has a value)
  712.  #  
  713.  #  'pkg' is either 'global' to mean a global preference, or the name 
  714.  #  of the mode or package (no spaces) for which this is a preference.
  715.  #  
  716.  #  'pname' is a procedure to call if this preference is changed by
  717.  #  the user (no need to setup a trace).  This proc is only called
  718.  #  for changes made through prefs dialogs or prefs menus created by
  719.  #  Alpha's core procs.  Other changes are not traced.
  720.  #  
  721.  #  Depending on the previous values, there are two optional arguments
  722.  #  with the following uses:
  723.  #  
  724.  #  TYPE:
  725.  #  
  726.  #  variable:
  727.  #  
  728.  #  'options' is a list of items from which this preference takes a single
  729.  #  item.
  730.  #  'subopt' is any of 'item', 'index', 'varitem' or 'varindex' or 'array', where
  731.  #  'item' indicates the pref is simply an item from the given list
  732.  #  of items, 'index' indicates it is an index into that list, and
  733.  #  'var*' indicates 'items' is in fact the name of a global variable
  734.  #  which contains the list. 'array' means take one of the values from an array.
  735.  #  If no value is given, 'item' is the default
  736.  #  
  737.  #  binding:
  738.  #  
  739.  #  'options' is the name of a proc to which this item should be bound.
  740.  #  If options = '1', then we Bind to the proc with the same name as
  741.  #  this variable.  Otherwise we do not perform automatic bindings.
  742.  #  
  743.  #  'subopt' indicates whether the binding is mode-specific or global.
  744.  #  It should either be 'global' or the name of a mode.  If not given,
  745.  #  it defaults to 'global' for all non-modes, and to mode-specific for
  746.  #  all packages.  (Alpha tests if something is a mode by the existence
  747.  #  of mode::features($mode))
  748.  # -------------------------------------------------------------------------
  749.  ##
  750. proc newPref {vtype {name {}} {val 0} {pkg "global"} {pname ""} {options ""} {subopt ""}} {
  751.     if {$name == {}} { uplevel 1 newPref $vtype}
  752.     
  753.     global allFlags allVars tclvars modeVars flag::procs \
  754.       flag::type flag::types alpha::earlyPrefs
  755.     # 'link' means link this variable with Alpha's internals.
  756.     if {[regexp {^early(.*)$} $vtype "" vtype]} {
  757.     lappend alpha::earlyPrefs $name
  758.     }
  759.     if {[regexp {^link(.*)$} $vtype "" vtype]} {
  760.     linkVar $name
  761.     # linked variables over-ride differently to normal preferences.
  762.     if {$val != ""} { global $name ; set $name $val }
  763.     }
  764.     set bad 1
  765.     foreach ty ${flag::types} {
  766.     if {[string first $vtype $ty] == 0} {
  767.         set vtype $ty
  768.         set bad 0
  769.         break
  770.     }
  771.     }
  772.     if {$bad} {
  773.     foreach ty {SearchPath Folder Path Mode Colour Color Sig} {
  774.         if {[string first $vtype [string tolower $ty]] == 0} {
  775.         if {[regexp -- "${ty}\$" $name]} {
  776.             set vtype variable
  777.             set bad 0
  778.             break
  779.         } else {
  780.             error "Type '$vtype' requires the variable's name to end in '$ty'"
  781.         }
  782.         }
  783.     }
  784.     if {$bad} {error "Unknown type '$vtype' in call to newPref"}
  785.     }
  786.     if {$pkg == "global"} {
  787.     switch -- $vtype {
  788.         "flag" {
  789.         lappend allFlags $name
  790.         }
  791.         "variable" {
  792.         lappend allVars $name
  793.         }
  794.         default {
  795.         set flag::type($name) $vtype
  796.         lappend allVars $name
  797.         }
  798.     }
  799.     
  800.     global $name
  801.     lunion tclvars $name
  802.     if {![info exists $name]} {set $name $val} else { set val [set $name] }
  803.     } else {
  804.     global ${pkg}modeVars
  805.     lunion modeVars $name
  806.     
  807.     if {![info exists ${pkg}modeVars($name)]} {
  808.         set ${pkg}modeVars($name) $val
  809.     } else {
  810.         set val [set ${pkg}modeVars($name)]
  811.     }
  812.     switch -- $vtype {
  813.         "flag" {
  814.         if {[lsearch -exact $allFlags $name] == -1} {
  815.             lappend allFlags $name
  816.         }
  817.         }
  818.         "variable" {
  819.         lappend allVars $name
  820.         }
  821.         default {
  822.         set flag::type($name) $vtype
  823.         lappend allVars $name
  824.         }
  825.     }
  826.     }
  827.     # handle 'options'
  828.     if {$options != ""} {
  829.     switch -- $vtype {
  830.         "variable" {
  831.         global flag::list
  832.         if {$subopt == ""} { set subopt "item" }
  833.         if {[lsearch -exact "array item index varitem varindex" $subopt] == -1} {
  834.             error "Unknown list element type '$subopt' in call to newPref."
  835.         }
  836.         set flag::list($name) [list $subopt $options]
  837.         }
  838.         "binding" {
  839.         global flag::binding mode::features
  840.         if {[info exists mode::features($pkg)]} {
  841.             if {$subopt == ""} { 
  842.             set subopt $pkg
  843.             } else {
  844.             if {$subopt == "global"} { set subopt "" }
  845.             }
  846.         } 
  847.         set flag::binding($name) [list $subopt $options]
  848.         if {$options == 1} { set options $name }
  849.         catch "Bind [keys::toBind $val] [list $options] $subopt"
  850.         }
  851.     }
  852.     }
  853.     # register the 'modify' proc
  854.     if {[string length $pname]} {
  855.     set flag::procs($name) $pname
  856.     }
  857. }
  858.  
  859. ## 
  860.  # -------------------------------------------------------------------------
  861.  # 
  862.  # "alpha::rectifyPackageCount" --
  863.  # 
  864.  #  Returns 1 if count has changed
  865.  # -------------------------------------------------------------------------
  866.  ##
  867. proc alpha::rectifyPackageCount {} {
  868.     global HOME file::separator
  869.     # check things haven't changed
  870.     foreach d {Modes Menus Packages} {
  871.     lappend count [llength [glob -nocomplain [file join ${HOME} Tcl ${d} "*\{.tcl,${file::separator}\}"]]]
  872.     }
  873.     if {![cache::exists index::count[join $count -]]} {
  874.     cache::deletePat index::count*
  875.     cache::create index::count[join $count -]
  876.     return 1
  877.     } else {
  878.     return 0
  879.     }
  880. }
  881.  
  882. proc alpha::checkConfiguration {} {
  883.     global alpha::version alpha::tclversion
  884.     if {![cache::exists index::feature] || (![cache::exists index::mode]) \
  885.       || ([alpha::package versions Alpha] != ${alpha::version}) \
  886.       || ([alpha::package versions AlphaTcl] != ${alpha::tclversion})} {
  887.     set rebuild 1
  888.     # If there's no package information stored at all, or if Alpha's
  889.     # version number has changed, zap the cache.  This may not be
  890.     # required, but is safer since core-code changes may modify the
  891.     # form of the cache, or change the format of cached menus etc.
  892.     global PREFS
  893.     if {[cache::exists configuration]} {
  894.         # in case we crashed or some other weirdness
  895.         catch {file delete [file join ${PREFS} configuration]}
  896.         # now backup the configuration file
  897.         file rename [file join ${PREFS} Cache configuration] \
  898.           [file join ${PREFS} configuration]
  899.         rm -r [file join ${PREFS} Cache]
  900.         file mkdir [file join ${PREFS} Cache]
  901.         file rename [file join ${PREFS} configuration] \
  902.           [file join ${PREFS} Cache configuration]
  903.     } else {
  904.         rm -r [file join ${PREFS} Cache]
  905.     }
  906.     } else {
  907.     set rebuild [alpha::rectifyPackageCount]
  908.     }
  909.     return $rebuild
  910. }
  911.  
  912.  
  913.